home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1995 September / macformat-028.iso / mac / Shareware City / Applications / ezGenes 0.2 PPC / Source 0.2 / UFamily.p < prev    next >
Encoding:
Text File  |  1995-06-10  |  32.7 KB  |  1,514 lines  |  [TEXT/MWPS]
  1. unit UFamily;
  2.  
  3. interface
  4.  
  5.     uses
  6.         UGridView, UTEView, UDialog, UMacApp, UFile;
  7.  
  8.     const
  9.         kNameSize = 31;        { Maximum size string supported for a name }
  10.         kSignature = 'famT'; { Application signature }
  11.         kFileType = 'text';    { File-type code used for document files }
  12.         kWindowID = 1025;    { The resource ID of the the view Resource }
  13.         kClusterID = 1034;
  14.         kPersonWindow = 1035;
  15.         kCoupleWindow = 1036;
  16.         kHandCursor = 1704;
  17.         kDontExist = '(*)';
  18.         kNotImplemented = 'Notes not yet implemented';
  19.  
  20.         cAncestor = 1201;
  21.         cDescendant = 1202;
  22.         cAddParents = 1211;
  23.         cAddSpouse = 1212;
  24.         cAddChild = 1213;
  25.         cEditPerson = 1218;
  26.         cDelePerson = 1219;
  27.         cDispFather = 1220;
  28.         cDispMother = 1221;
  29.         cDispSpouse = 1222;
  30.         cDispChild = 1223;
  31.         cGoto = 1229;
  32.  
  33.  
  34.     type
  35.  
  36.         NameStr = string[kNameSize];
  37.  
  38.         TPerson = object(TSortedList)
  39.  
  40.                 fFirst, fLast: NameStr;
  41.                 fBirth, fDeath: longint;
  42.                 fPlace: NameStr;
  43.                 fMale: boolean;
  44.                 parents: TCouple;
  45. {spouses: TCoupleList;    Dynamic fields appended at the end of object--see TList}
  46.  
  47.                 procedure TPerson.Init;
  48.  
  49.                 function TPerson.FullName: str255;
  50.  
  51.                 function TPerson.FullBirth: str255;
  52.  
  53.                 procedure TPerson.AddParents (C: TCouple);
  54.  
  55.                 procedure TPerson.AddSpouse (C: TCouple);
  56.  
  57.                 procedure TPerson.AddChild (P: TPerson);
  58.  
  59.                 function TPerson.Father: TPerson;
  60.  
  61.                 function TPerson.Mother: TPerson;
  62.  
  63.                 function TPerson.Spouse (k: integer): TPerson;
  64.  
  65.                 function TPerson.NumberOfDescendants: integer;
  66.  
  67.                 procedure TPerson.WriteDescendants (F: TTextFile; n: integer);
  68.  
  69.                 procedure TPerson.MakeDescendants (n: integer);
  70.  
  71.                 procedure TPerson.MakeAncestors (n: integer);
  72.  
  73.                 function TPerson.Compare (item1, item2: TObject): CompareResult;
  74.                 OVERRIDE;
  75.                 procedure TPerson.GetInspectorName (var inspectorName: Str255);
  76.                 OVERRIDE;
  77.                 procedure TPerson.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  78.                 OVERRIDE;
  79.                 procedure TPerson.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  80.                 OVERRIDE;
  81.             end;
  82.  
  83.  
  84.         TPersonList = object(TSortedList)
  85.  
  86.                 procedure TPersonList.Init;
  87.  
  88.                 function TPersonList.Compare (item1, item2: TObject): CompareResult;
  89.                 OVERRIDE;
  90.             end;
  91.  
  92.  
  93.         TCouple = object(TSortedList)
  94.  
  95.                 husband, wife: TPerson;
  96.                 fDate: longint;
  97. {children: TPersonList;    Dynamic fields}
  98.  
  99.                 procedure TCouple.Init;
  100.  
  101.                 function TCouple.Compare (item1, item2: TObject): CompareResult;
  102.                 OVERRIDE;
  103.                 procedure TCouple.GetInspectorName (var inspectorName: Str255);
  104.                 OVERRIDE;
  105.                 procedure TCouple.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  106.                 OVERRIDE;
  107.                 procedure TCouple.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  108.                 OVERRIDE;
  109.             end;
  110.  
  111.  
  112.         TCoupleList = TList;
  113.  
  114.  
  115.         TFamilyDoc = object(TDocument)
  116.  
  117.                 fMen, fWomen: TPersonList;
  118.                 fCouples: TCoupleList;
  119.                 fCurrent: TPerson;
  120.                 fFamily: TList;
  121.  
  122.                 iFather, iMother: TActiveText;
  123.                 iName, iBirth: TStaticText;
  124.                 iNote: TEditText;
  125.                 iFamily: TFamilyView;
  126.  
  127.                 procedure TFamilyDoc.Init;
  128.  
  129.                 procedure TFamilyDoc.Free;
  130.                 OVERRIDE;
  131.                 function TFamilyDoc.NewPerson (isMale: boolean): TPerson;
  132.  
  133.                 function TFamilyDoc.NewCouple (Husband, Wife: TPerson): TCouple;
  134.  
  135.                 function TFamilyDoc.EditPerson (P: TPerson; title: str255): boolean;
  136.  
  137.                 function TFamilyDoc.EditCouple (C: TCouple; L1, L2: str255): boolean;
  138.  
  139.                 procedure TFamilyDoc.AddPerson (P: TPerson);
  140.  
  141.                 procedure TFamilyDoc.RemovePerson (P: TPerson);
  142.  
  143.                 procedure TFamilyDoc.DeletePerson (P: TPerson);
  144.  
  145.                 procedure TFamilyDoc.AddParents;
  146.  
  147.                 procedure TFamilyDoc.AddSpouse;
  148.  
  149.                 procedure TFamilyDoc.AddChild;
  150.  
  151.                 procedure TFamilyDoc.SetPerson (P: TPerson);
  152.  
  153.                 procedure TFamilyDoc.SetFamilyView;
  154.  
  155.                 procedure TFamilyDoc.DoMakeViews (forPrinting: BOOLEAN);
  156.                 OVERRIDE;
  157.                 procedure TFamilyDoc.DoChoice (origView: TView; itsChoice: INTEGER);
  158.                 OVERRIDE;
  159.                 procedure TFamilyDoc.DoSetupMenus;
  160.                 OVERRIDE;
  161.                 function TFamilyDoc.DoMenuCommand (aCmdNumber: CmdNumber): TCommand;
  162.                 OVERRIDE;
  163.                 function TFamilyDoc.DoKeyCommand (ch: Char; aKeyCode: INTEGER; var info: EventInfo): TCommand;
  164.                 OVERRIDE;
  165.                 procedure TFamilyDoc.DoInitialState;
  166.                 OVERRIDE;
  167.                 procedure TFamilyDoc.DoRead (aRefNum: INTEGER; rsrcExists, forPrinting: BOOLEAN);
  168.                 OVERRIDE;
  169.                 procedure TFamilyDoc.DoWrite (aRefNum: INTEGER; makingCopy: BOOLEAN);
  170.                 OVERRIDE;
  171.                 procedure TFamilyDoc.DoNeedDiskSpace (var dataForkBytes, rsrcForkBytes: LONGINT);
  172.                 OVERRIDE;
  173.                 procedure TFamilyDoc.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  174.                 OVERRIDE;
  175.             end;
  176.  
  177.  
  178.         TFamilyView = object(TTextListView)
  179.  
  180.                 fSpouses: set of 0..31;
  181.  
  182.                 procedure TFamilyView.GetItemText (anItem: INTEGER; var aString: Str255);
  183.                 OVERRIDE;
  184.                 procedure TFamilyView.SelectItem (anItem: INTEGER; extendSelection, highlight, select: BOOLEAN);
  185.                 OVERRIDE;
  186.                 procedure TFamilyView.SetNumberOfItems (aNumber: INTEGER);
  187.  
  188.                 procedure TFamilyView.DrawCell (aCell: GridCell; aQDRect: Rect);
  189.                 OVERRIDE;
  190.                 function TFamilyView.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
  191.                 OVERRIDE;
  192.             end;
  193.  
  194.  
  195.         TActiveText = object(TStaticText)
  196.  
  197.                 fPerson: TPerson;
  198.  
  199.                 procedure TActiveText.SetPerson (P: TPerson);
  200.  
  201.                 function TActiveText.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
  202.                 OVERRIDE;
  203.                 procedure TActiveText.DoChoice (origView: TView; itsChoice: INTEGER);
  204.                 OVERRIDE;
  205.             end;
  206.  
  207.         TPersonCluster = object(TCluster)
  208.  
  209.                 iMale: TCheckBox;
  210.                 iFrst: TEditText;
  211.                 iLast: TEditText;
  212.                 iPlac: TEditText;
  213.                 iBirt: TNumberText;
  214.                 iDeat: TNumberText;
  215.                 iNote: TEditText;
  216.  
  217.                 procedure TPersonCluster.Init;
  218.  
  219.                 procedure TPersonCluster.GetDataFrom (P: TPerson);
  220.  
  221.                 procedure TPersonCluster.PutDataInto (P: TPerson);
  222.  
  223.             end;
  224.  
  225.  
  226.     var
  227.         gPersonData, gHusbandData, gWifeData: TPersonCluster;
  228.         gBlue, gRed: RGBColor;
  229.  
  230.  
  231.     procedure InitMyDialogs;
  232.  
  233.  
  234. implementation
  235.  
  236.     uses
  237.         UDebug;
  238.  
  239.  
  240.     procedure InitMyDialogs;
  241.         var
  242.             W: TWindow;
  243.             D: TDialogView;
  244.             offset: longint;
  245.     begin
  246.         W := NewTemplateWindow(kPersonWindow, nil);
  247.         FailNIL(W);
  248.         D := TDialogView(W.FindSubView('dlog'));
  249.         FailNIL(D);
  250.  
  251.         gPersonData := TPersonCluster(gApplication.DoCreateViews(nil, D, kClusterID, gZeroVPt));
  252.         FailNIL(gPersonData);
  253.         gPersonData.Init;
  254.         offset := W.fSize.v - 16;
  255.  
  256.         W := NewTemplateWindow(kCoupleWindow, nil);
  257.         FailNIL(W);
  258.         D := TDialogView(W.FindSubView('dlog'));
  259.         FailNIL(D);
  260.  
  261.         gHusbandData := TPersonCluster(gApplication.DoCreateViews(nil, D, kClusterID, gZeroVPt));
  262.         FailNIL(gHusbandData);
  263.         gHusbandData.Init;
  264.         gHusbandData.fIdentifier := 'husb';
  265.         gHusbandData.iMale.DimState(true, false);
  266.         D.MakeFirstSubview(gHusbandData);
  267.  
  268.         gWifeData := TPersonCluster(gApplication.DoCreateViews(nil, D, kClusterID, gZeroVPt));
  269.         FailNIL(gWifeData);
  270.         gWifeData.Init;
  271.         gWifeData.fIdentifier := 'wife';
  272.         gWifeData.iMale.DimState(true, false);
  273.         with gWifeData.fLocation do
  274.             v := v + offset;
  275.  
  276.         SetRGBColor(gBlue, 0, 0, $D400);
  277.         SetRGBColor(gRed, $DD6B, $8C2, $6A2);
  278.     end;
  279.  
  280.     function OpenNewFile (prompt, fName: Str255; Owner, Kind: OSType): INTEGER;
  281.         var
  282.             FS: FSSpec;
  283.             Reply: StandardFileReply;
  284.             err, fFile: integer;
  285.     begin
  286.         OpenNewFile := kNoFileRefnum;
  287.         gApplication.UpdateAllWindows;
  288.         StandardPutFile(prompt, fName, reply);
  289.  
  290.         if Reply.sfGood then
  291.             begin
  292.                 FS := Reply.sfFile;
  293.                 err := FSpOpenDF(FS, fsCurPerm, fFile);
  294.                 if err <> fnfErr then
  295.                     FailOSErr(err)
  296.                 else
  297.                     begin
  298.                         FailOSErr(FSpCreate(FS, Owner, Kind, Reply.sfScript));
  299.                         FailOSErr(FSpOpenDF(FS, fsCurPerm, fFile));
  300.                     end;
  301.                 OpenNewFile := fFile;
  302.             end;
  303.     end;
  304.  
  305. {==========================================================================}
  306. {        TPerson                                                 }
  307. {==========================================================================}
  308.     procedure TPerson.Init;
  309.     begin
  310.         ISortedList;
  311.         fFirst := '';
  312.         fLast := '';
  313.         fBirth := 0;
  314.         fDeath := 0;
  315.         fPlace := '';
  316.         fMale := true;
  317.         parents := nil;
  318. {$IFC qDebug}
  319.         SetEltType('TCouple');
  320. {$ENDC}
  321.     end;
  322.  
  323.     function TPerson.FullName: str255;
  324.     begin
  325.         FullName := concat(fFirst, ' ', fLast);
  326.     end;
  327.  
  328.     function TPerson.FullBirth: str255;
  329.         var
  330.             B, D: str255;
  331.     begin
  332.         if fBirth = 0 then
  333.             FullBirth := ''
  334.         else
  335.             begin
  336.                 NumToString(fBirth, B);
  337.                 if fDeath = 0 then
  338.                     FullBirth := B
  339.                 else
  340.                     begin
  341.                         NumToString(fDeath, D);
  342.                         FullBirth := concat(B, '-', D);
  343.                     end;
  344.             end;
  345.     end;
  346.  
  347.     procedure TPerson.AddParents (C: TCouple);
  348.     begin
  349.         SELF.parents := C;
  350.         C.Insert(SELF);
  351.     end;
  352.  
  353.     procedure TPerson.AddSpouse (C: TCouple);
  354.     begin
  355.         SELF.Insert(C);
  356.         if fMale then
  357.             C.wife.Insert(C)
  358.         else
  359.             C.husband.Insert(C);
  360.     end;
  361.  
  362.     procedure TPerson.AddChild (P: TPerson);
  363.         var
  364.             C: TCouple;
  365.     begin
  366.         C := TCouple(SELF.Last);    {last marriage}
  367.         P.parents := C;
  368.         C.Insert(P);
  369.     end;
  370.  
  371.     function TPerson.Father: TPerson;
  372.     begin
  373.         if parents = nil then
  374.             Father := nil
  375.         else
  376.             Father := parents.husband;
  377.     end;
  378.  
  379.     function TPerson.Mother: TPerson;
  380.     begin
  381.         if parents = nil then
  382.             Mother := nil
  383.         else
  384.             Mother := parents.wife;
  385.     end;
  386.  
  387.     function TPerson.Spouse (k: integer): TPerson;
  388.         var
  389.             C: TCouple;
  390.     begin
  391.         if (fSize < k) then
  392.             Spouse := nil
  393.         else
  394.             begin
  395.                 C := TCouple(At(k));
  396.                 if fMale then
  397.                     Spouse := C.wife
  398.                 else
  399.                     Spouse := C.husband;
  400.             end;
  401.     end;
  402.  
  403.     function TPerson.NumberOfDescendants: integer;
  404.         var
  405.             n: integer;
  406.  
  407.         procedure DoToChild (P: TPerson);
  408.         begin
  409.             n := n + P.NumberOfDescendants;
  410.         end;
  411.  
  412.         procedure DoToSpouse (C: TCouple);
  413.         begin
  414.             C.Each(DoToChild);
  415.         end;
  416.  
  417.     begin
  418.         if fSize = 0 then
  419.             NumberOfDescendants := 1    {Always count yourself!}
  420.         else
  421.             begin
  422.                 n := 0;
  423.                 Each(DoToSpouse);
  424.                 NumberOfDescendants := n + 1;
  425.             end;
  426.     end;
  427.  
  428.     function TABs (n: integer): str255;
  429.         var
  430.             k: integer;
  431.             S: str255;
  432.     begin
  433.         S[0] := chr(n);
  434.         for k := 1 to n do
  435.             S[k] := chTAB;
  436.         TABs := S;
  437.     end;
  438.  
  439.     procedure TPerson.WriteDescendants (F: TTextFile; n: integer);
  440.         var
  441.             S: str255;
  442.  
  443.         procedure DoToChild (P: TPerson);
  444.         begin
  445.             if (P.fSize = 0) | (n = 0) then
  446.                 begin
  447. {$IFC qDebug}
  448.                     writeln(' ' : 4 * (5 - n), P.fFirst);
  449. {$ENDC}
  450.                     S := concat(TABs(5 - n), P.fFirst);
  451.                     F.WriteLine(S);
  452.                 end
  453.             else
  454.                 P.WriteDescendants(F, n - 1);
  455.         end;
  456.  
  457.         procedure DoToSpouse (C: TCouple);
  458.         begin
  459.             NumToString(C.fDate, S);
  460. {$IFC qDebug}
  461.             if fMale then
  462.                 writeln(' ' : 4 * (4 - n), C.husband.fFirst, ' <', S, '> ', C.wife.fFirst)
  463.             else
  464.                 writeln(' ' : 4 * (4 - n), C.wife.fFirst, ' <', S, '> ', C.husband.fFirst);
  465. {$ENDC}
  466.             if fMale then
  467.                 S := concat(TABs(4 - n), C.husband.FullName, ' <', S, '> ', C.wife.FullName)
  468.             else
  469.                 S := concat(TABs(4 - n), C.wife.FullName, ' <', S, '> ', C.husband.FullName);
  470.             F.WriteLine(S);
  471.             C.Each(DoToChild);
  472.         end;
  473.  
  474.     begin
  475.         Each(DoToSpouse);
  476.     end;
  477.  
  478.     procedure TPerson.MakeDescendants (n: integer);
  479.         var
  480.             F: TTextFile;
  481.             RefNum, err: integer;
  482.             S: str255;
  483.  
  484.     begin
  485.         S := concat(SELF.FullName, ' >>');
  486. {$IFC qDebug}
  487.         writeln(S);
  488. {$ENDC}
  489.         RefNum := OpenNewFile('Descendants', S, 'ttxt', 'TEXT');
  490.         new(F);
  491.         FailNil(F);
  492.         F.ITextFile(RefNum, kDisk);
  493.  
  494.         WriteDescendants(F, n);
  495.  
  496.         F.Free;
  497.         err := FSClose(RefNum);
  498.     end;
  499.  
  500.     procedure TPerson.MakeAncestors (n: integer);
  501.         var
  502.             F: TTextFile;
  503.             RefNum, err: integer;
  504.             S: str255;
  505.  
  506.         procedure DoToParents (P: TPerson; n: integer);
  507.         begin
  508.             if (n > 0) and (P.Father <> nil) then
  509.                 DoToParents(P.Father, n - 1);
  510. {$IFC qDebug}
  511.             writeln(' ' : 8 * n, P.fFirst);
  512. {$ENDC}
  513.             S := concat(TABs(n), P.FullName);
  514.             F.WriteLine(S);
  515.             S := concat(TABs(n), P.FullBirth, '  ', P.fPlace);
  516.             F.WriteLine(S);
  517.             if (n > 0) and (P.Mother <> nil) then
  518.                 DoToParents(P.Mother, n - 1);
  519.         end;
  520.  
  521.     begin
  522.         S := concat('>> ', SELF.FullName);
  523. {$IFC qDebug}
  524.         writeln(S);
  525. {$ENDC}
  526.         RefNum := OpenNewFile('Ancestors', S, 'ttxt', 'TEXT');
  527.         new(F);
  528.         FailNil(F);
  529.         F.ITextFile(RefNum, kDisk);
  530.  
  531.         DoToParents(SELF, n);
  532.  
  533.         F.Free;
  534.         err := FSClose(RefNum);
  535.     end;
  536.  
  537.     function TPerson.Compare (item1, item2: TObject): CompareResult;
  538.         OVERRIDE;
  539.     begin
  540.         Compare := (TCouple(item1).fDate - TCouple(item2).fDate);
  541.     end;
  542.  
  543.     procedure TPersonList.Init;
  544.     begin
  545.         ISortedList;
  546. {$IFC qDebug}
  547.         SetEltType('TPerson');
  548. {$ENDC}
  549.     end;
  550.  
  551.     function TPersonList.Compare (item1, item2: TObject): CompareResult;
  552.         OVERRIDE;
  553.     begin
  554.         Compare := IUCompString(TPerson(item1).fFirst, TPerson(item2).fFirst)
  555.     end;
  556.  
  557. {==========================================================================}
  558. {        TCouple                                                 }
  559. {==========================================================================}
  560.     procedure TCouple.Init;
  561.     begin
  562.         ISortedList;
  563.         husband := nil;
  564.         wife := nil;
  565.         fDate := 0;
  566. {$IFC qDebug}
  567.         SetEltType('TPerson');
  568. {$ENDC}
  569.     end;
  570.  
  571.     function TCouple.Compare (item1, item2: TObject): CompareResult;
  572.         OVERRIDE;
  573.     begin
  574.         Compare := (TPerson(item1).fBirth - TPerson(item2).fBirth);
  575.     end;
  576.  
  577.  
  578. {==========================================================================}
  579. {        TFamilyDoc                                             }
  580. {==========================================================================}
  581.     procedure TFamilyDoc.Init;
  582.     begin
  583.         IDocument(kFileType, kSignature, kUsesDataFork, not kUsesRsrcFork, not kDataOpen, not kRsrcOpen);
  584.         fSavePrintInfo := false;
  585.  
  586.         new(fMen);
  587.         FailNil(fMen);
  588.         fmen.init;
  589.         new(fWomen);
  590.         FailNil(fWomen);
  591.         fWomen.init;
  592.         fCouples := TCoupleList(newList);
  593. {$IFC qDebug}
  594.         fCouples.SetEltType('TCouple');
  595. {$ENDC}
  596.  
  597.         fCurrent := nil;
  598.         fFamily := newList;
  599. {$IFC qDebug}
  600.         fFamily.SetEltType('TPerson');
  601. {$ENDC}
  602.         iFather := nil;
  603.         iMother := nil;
  604.         iName := nil;
  605.         iBirth := nil;
  606.         iNote := nil;
  607.         iFamily := nil;
  608.     end;
  609.  
  610.     procedure TFamilyDoc.Free;
  611.         OVERRIDE;
  612.     begin
  613.         fMen.FreeList;        {Free all the elements, as well as the list}
  614.         fWomen.FreeList;
  615.         fCouples.FreeList;
  616.         fFamily.Free;
  617.  
  618.         inherited Free;
  619.     end;
  620.  
  621.     function TFamilyDoc.NewPerson (isMale: boolean): TPerson;
  622.         var
  623.             P: TPerson;
  624.     begin
  625.         New(P);
  626.         FailNil(P);
  627.         P.Init;
  628.         P.fMale := isMale;
  629.         NewPerson := P;
  630.     end;
  631.  
  632.     function TFamilyDoc.NewCouple (Husband, Wife: TPerson): TCouple;
  633.         var
  634.             C: TCouple;
  635.     begin
  636.         New(C);
  637.         FailNil(C);
  638.         C.Init;
  639.         C.husband := Husband;
  640.         C.wife := Wife;
  641.         NewCouple := C;
  642.     end;
  643.  
  644.     function TFamilyDoc.EditPerson (P: TPerson; title: str255): boolean;
  645.         var
  646.             D: TDialogView;
  647.             dismisser: IDType;
  648.             wasMale: boolean;
  649.     begin
  650.         D := TDialogView(gPersonData.GetDialogView);
  651.         wasMale := P.fMale;
  652.         gPersonData.SetLabel(title, false);
  653.         gPersonData.GetDataFrom(P);
  654.         gPersonData.iMale.DimState(P.fSize > 0, false);    {cannot modify sex of a married person}
  655.         D.DoSelectEditText(gPersonData.iFrst, kSelect);
  656.  
  657.         dismisser := D.PoseModally;
  658.         D.GetWindow.Close;
  659.  
  660.         if dismisser = 'cncl' then
  661.             begin
  662.                 EditPerson := false;
  663.                 exit(EditPerson);
  664.             end;
  665.         EditPerson := true;
  666.         SetChangeCount(fChangeCount + 1);
  667.         gPersonData.PutDataInto(P);
  668.         if wasMale <> P.fMale then
  669.             AddPerson(P);
  670.     end;
  671.  
  672.     function TFamilyDoc.EditCouple (C: TCouple; L1, L2: str255): boolean;
  673.         var
  674.             D: TDialogView;
  675.             dismisser: IDType;
  676.             iDate: TNumberText;
  677.     begin
  678.         D := TDialogView(gHusbandData.GetDialogView);
  679.  
  680.         iDate := TNumberText(D.FindSubView('date'));
  681.         FailNIL(iDate);
  682.         iDate.SetValue(C.fDate, false);
  683.  
  684.         gHusbandData.SetLabel(L1, false);
  685.         gHusbandData.GetDataFrom(C.husband);
  686.         gWifeData.SetLabel(L2, false);
  687.         gWifeData.GetDataFrom(C.wife);
  688.         D.DoSelectEditText(iDate, kSelect);
  689.  
  690.         dismisser := D.PoseModally;
  691.         D.GetWindow.Close;
  692.  
  693.         if dismisser = 'cncl' then
  694.             begin
  695.                 EditCouple := false;
  696.                 exit(EditCouple);
  697.             end;
  698.         EditCouple := true;
  699.         SetChangeCount(fChangeCount + 1);
  700.         gHusbandData.PutDataInto(C.husband);
  701.         gWifeData.PutDataInto(C.wife);
  702.         C.fDate := iDate.GetValue;
  703.     end;
  704.  
  705.     procedure TFamilyDoc.AddPerson (P: TPerson);
  706.     begin
  707.         fMen.Delete(P);
  708.         fWomen.Delete(P);
  709.         if P.fMale then
  710.             fMen.Insert(P)
  711.         else
  712.             fWomen.Insert(P);
  713.     end;
  714.  
  715.     procedure TFamilyDoc.RemovePerson (P: TPerson);
  716.     begin
  717.         if P.fMale then
  718.             fMen.Delete(P)
  719.         else
  720.             fWomen.Delete(P);
  721.     end;
  722.  
  723.     procedure TFamilyDoc.DeletePerson (P: TPerson);
  724.         var
  725.             C: TCouple;
  726.     begin
  727.         P := fCurrent;
  728.         C := P.parents;
  729.         C.Delete(P);
  730.         SetChangeCount(fChangeCount + 1);
  731.         RemovePerson(P);
  732.         SetPerson(P.Father);
  733.         P.Free;
  734.     end;
  735.  
  736.     procedure TFamilyDoc.AddParents;
  737.         var
  738.             C: TCouple;
  739.             F, M: TPerson;
  740.     begin
  741.         F := NewPerson(true);    {'Father',}
  742.         M := NewPerson(false);    {'Mother',}
  743.         C := NewCouple(F, M);
  744.         F.fLast := fCurrent.fLast;
  745.         if EditCouple(C, 'Father', 'Mother') then
  746.             begin
  747.                 F.AddSpouse(C);
  748.                 fCurrent.AddParents(C);
  749.                 AddPerson(F);
  750.                 AddPerson(M);
  751.                 fCouples.Insert(C);
  752.             end
  753.         else
  754.             begin
  755.                 F.Free;
  756.                 M.Free;
  757.                 C.Free;
  758.             end;
  759.     end;
  760.  
  761.     procedure TFamilyDoc.AddSpouse;
  762.         var
  763.             P: TPerson;
  764.             C: TCouple;
  765.     begin
  766.         P := NewPerson(not fCurrent.fMale);        {'Spouse',}
  767.         if fCurrent.fMale then
  768.             C := NewCouple(fCurrent, P)
  769.         else
  770.             C := NewCouple(P, fCurrent);
  771.         if EditCouple(C, 'Husband', 'Wife') then
  772.             begin
  773.                 fCurrent.AddSpouse(C);
  774.                 AddPerson(P);
  775.                 fCouples.Insert(C);
  776.             end
  777.         else
  778.             begin
  779.                 P.Free;
  780.                 C.Free;
  781.             end;
  782.     end;
  783.  
  784.     procedure TFamilyDoc.AddChild;
  785.         var
  786.             P: TPerson;
  787.     begin
  788.         P := NewPerson(true);    {default is male}
  789.         P.fLast := TCouple(fCurrent.Last).husband.fLast;
  790.         if EditPerson(P, 'Child') then
  791.             begin
  792.                 fCurrent.AddChild(P);
  793.                 AddPerson(P);
  794.             end
  795.         else
  796.             begin
  797.                 P.Free;
  798.             end;
  799.     end;
  800.  
  801.     procedure TFamilyDoc.SetPerson (P: TPerson);
  802.         var
  803.             S: str255;
  804.     begin
  805.         FailNil(P);
  806.         fCurrent := P;
  807.         iFather.SetPerson(P.Father);
  808.         iMother.SetPerson(P.Mother);
  809.         if P.fMale then
  810.             iName.InstallColor(gBlue, false)
  811.         else
  812.             iName.InstallColor(gRed, false);
  813.         iName.SetText(P.FullName, kRedraw);
  814.         S := concat(P.FullBirth, '  ', P.fPlace);
  815.         iBirth.Settext(S, kRedraw);
  816.         NumToString(fCurrent.NumberOfDescendants, S);
  817.         iNote.SetText(S, kRedraw);
  818.         SetFamilyView;
  819.     end;
  820.  
  821.     procedure TFamilyDoc.SetFamilyView;
  822.  
  823.         procedure DoToChild (child: TObject);
  824.         begin
  825.             fFamily.InsertLast(child);
  826.         end;
  827.  
  828.         procedure DoToSpouse (C: TCouple);
  829.         begin
  830.             if fCurrent.fMale then
  831.                 fFamily.InsertLast(C.wife)
  832.             else
  833.                 fFamily.InsertLast(C.husband);
  834.             iFamily.fSpouses := iFamily.fSpouses + [fFamily.fSize];
  835.             C.Each(DoToChild);
  836.         end;
  837.  
  838.     begin
  839.         iFamily.fSpouses := [];
  840.         fFamily.DeleteAll;
  841.         fCurrent.Each(DoToSpouse);
  842.         iFamily.SetNumberOfItems(fFamily.fSize + 1);
  843.         iFamily.SelectItem(0, false, false, true);
  844.     end;
  845.  
  846.     procedure TFamilyDoc.DoMakeViews (forPrinting: BOOLEAN);
  847.         OVERRIDE;
  848.         var
  849.             W: TWindow;
  850.     begin
  851. {$IFC qDebug}
  852. {gIntenseDebugging := true;}
  853. {gTracing := true;}
  854. {$ENDC}
  855.         W := NewTemplateWindow(kWindowID, SELF);
  856. {$IFC qDebug}
  857. {gTracing := false;}
  858. {gIntenseDebugging := false;}
  859. {$ENDC}
  860.         FailNIL(W);
  861.  
  862.         iFather := TActiveText(W.FindSubView('fadr'));
  863.         iFather.fDocument := SELF;
  864.         iFather.SetPerson(nil);
  865.         iMother := TActiveText(W.FindSubView('modr'));
  866.         iMother.fDocument := SELF;
  867.         iMother.SetPerson(nil);
  868.         iName := TStaticText(W.FindSubView('name'));
  869.         iBirth := TStaticText(W.FindSubView('birt'));
  870.         iNote := TEditText(W.FindSubView('note'));
  871.         iFamily := TFamilyView(W.FindSubView('faml'));
  872.  
  873.         if fMen.fSize = 0 then        {We cannot do this at DoRead or ‹nitialState--View needed!}
  874.             SetPerson(TPerson(fWomen.At(1)))
  875.         else
  876.             SetPerson(TPerson(fMen.At(1)));
  877.     end;
  878.  
  879.     procedure TFamilyDoc.DoChoice (origView: TView; itsChoice: INTEGER);
  880.         OVERRIDE;
  881.     begin
  882. {$IFC false}
  883.         WRITELN('DoChoice  ', origView.fIdentifier, itsChoice);
  884. {$ENDC}
  885.         if (origView.fIdentifier = 'name') & EditPerson(fCurrent, fCurrent.fFirst) then
  886.             SetPerson(fCurrent);
  887.     end;
  888.  
  889.     procedure TFamilyDoc.DoSetupMenus;
  890.         OVERRIDE;
  891.         var
  892.             KnownParents: boolean;
  893.     begin
  894.         inherited DoSetupMenus;
  895.  
  896.         KnownParents := (fCurrent.parents <> nil);
  897.  
  898.         Enable(cAncestor, fCurrent.parents <> nil);
  899.         Enable(cDescendant, fCurrent.fSize > 0);
  900.         Enable(cAddParents, not KnownParents);
  901.         Enable(cAddSpouse, true);
  902.         Enable(cAddChild, true);
  903.  
  904.         Enable(cEditPerson, true);
  905.         Enable(cDelePerson, KnownParents & (fCurrent.fSize = 0));
  906.  
  907.         Enable(cDispFather, KnownParents);
  908.         Enable(cDispMother, KnownParents);
  909.         Enable(cDispSpouse, fFamily.fSize > 0);
  910.         Enable(cDispChild, fFamily.fSize > 1);
  911.  
  912. {Enable(cSave, TRUE);}
  913.     end;
  914.  
  915.     function TFamilyDoc.DoMenuCommand (aCmdNumber: CmdNumber): TCommand;
  916.         OVERRIDE;
  917.     begin
  918.         DoMenuCommand := nil;
  919.         case aCmdNumber of
  920.             cAncestor: 
  921.                 fCurrent.MakeAncestors(4);
  922.             cDescendant: 
  923.                 fCurrent.MakeDescendants(4);
  924.             cAddParents: 
  925.                 iFather.DoChoice(iFather, 0);
  926.             cAddSpouse: 
  927.                 begin        {option-click on last item of iFamily}
  928.                     AddSpouse;
  929.                     SetPerson(fCurrent);
  930.                 end;
  931.             cAddChild: 
  932.                 iFamily.SelectItem(fFamily.fSize + 1, false, false, true);
  933.             cEditPerson: 
  934.                 DoChoice(iName, 0);
  935.             cDelePerson: 
  936.                 DeletePerson(fCurrent);
  937.             cDispFather: 
  938.                 iFather.DoChoice(iFather, 0);
  939.             cDispMother: 
  940.                 iMother.DoChoice(iMother, 0);
  941.             cDispSpouse: 
  942.                 iFamily.SelectItem(1, false, false, true);
  943.             cDispChild: 
  944.                 iFamily.SelectItem(2, false, false, true);
  945. {cGoto: ;}
  946.             otherwise
  947.                 DoMenuCommand := inherited DoMenuCommand(aCmdNumber);
  948.         end;
  949.     end;
  950.  
  951.     function TFamilyDoc.DoKeyCommand (ch: Char; aKeyCode: INTEGER; var info: EventInfo): TCommand;
  952.         OVERRIDE;
  953.         var
  954.             k: integer;
  955.     begin
  956.         DoKeyCommand := nil;
  957.         case ch of
  958.             chReturn: 
  959.                 DoChoice(iName, 0);
  960.             'F', 'f': 
  961.                 iFather.DoChoice(iFather, 0);
  962.             'M', 'm': 
  963.                 iMother.DoChoice(iMother, 0);
  964.             '1'..'9': 
  965.                 begin
  966.                     k := ord(ch) - ord('0');
  967.                     if k <= fFamily.fSize + 1 then
  968.                         iFamily.SelectItem(k, false, false, true);
  969.                 end;
  970.             otherwise
  971.                 DoKeyCommand := inherited DoKeyCommand(ch, aKeyCode, info);
  972.         end;
  973.     end;
  974.  
  975.     procedure TFamilyDoc.DoInitialState;
  976.         OVERRIDE;
  977.         var
  978.             P: TPerson;
  979.     begin
  980.         P := NewPerson(true);
  981.         if EditPerson(P, 'First Person') then
  982.             AddPerson(P)
  983.         else
  984.             begin
  985.                 P.Free;
  986.                 Failure(0, 0);
  987.             end;
  988.     end;
  989.  
  990.     procedure TFamilyDoc.DoRead (aRefNum: INTEGER; rsrcExists, forPrinting: BOOLEAN);
  991.         OVERRIDE;
  992.         var
  993.             F: TTextFile;
  994.             pos: integer;
  995.             Line: str255;
  996.  
  997.         procedure ReadNewLine;
  998.         begin
  999.             Line := F.NextLine;
  1000.             pos := 0;
  1001.         end;
  1002.  
  1003.         function NextField: str255;
  1004.             var
  1005.                 i: integer;
  1006.                 X: str255;
  1007.         begin
  1008.             i := 0;
  1009.             pos := pos + 1;
  1010.             while (pos <= length(Line)) & (Line[pos] <> chTAB) do
  1011.                 begin
  1012.                     i := i + 1;
  1013.                     X[i] := Line[pos];
  1014.                     pos := pos + 1;
  1015.                 end;
  1016.             X[0] := chr(i);
  1017.             NextField := X;
  1018.         end;
  1019.  
  1020.         procedure InitLists;
  1021.             var
  1022.                 N: longint;
  1023.                 k: integer;
  1024.                 P: TPerson;
  1025.                 C: TCouple;
  1026.         begin
  1027.             ReadNewLine;
  1028.             StringToNum(NextField, N);
  1029.             for k := 1 to N do
  1030.                 begin
  1031.                     New(P);
  1032.                     FailNil(P);
  1033.                     P.Init;
  1034.                     P.fMale := true;
  1035.                     fMen.InsertLast(P);
  1036.                 end;
  1037.  
  1038.             StringToNum(NextField, N);
  1039.             for k := 1 to N do
  1040.                 begin
  1041.                     New(P);
  1042.                     FailNil(P);
  1043.                     P.Init;
  1044.                     P.fMale := false;
  1045.                     fWomen.InsertLast(P);
  1046.                 end;
  1047.  
  1048.             StringToNum(NextField, N);
  1049.             for k := 1 to N do
  1050.                 begin
  1051.                     New(C);
  1052.                     FailNil(C);
  1053.                     C.Init;
  1054.                     fCouples.InsertLast(C);
  1055.                 end;
  1056.         end;
  1057.  
  1058.         procedure ReadPerson (P: TPerson);
  1059.             var
  1060.                 N: longint;
  1061.                 T: str255;
  1062.         begin
  1063.             ReadNewLine;
  1064.             T := NextField;    {Skip record number}
  1065.             P.fFirst := NextField;
  1066.             P.fLast := NextField;
  1067.             P.fPlace := NextField;
  1068.             StringToNum(NextField, N);
  1069.             P.fBirth := N;
  1070.             StringToNum(NextField, N);
  1071.             P.fDeath := N;
  1072.             StringToNum(NextField, N);
  1073. {$IFC qDebug}
  1074.             WRITELN(T, ' ', P.fFirst, N);
  1075. {$ENDC}
  1076.             if N <> 0 then
  1077.                 P.AddParents(TCouple(fCouples.At(N)));
  1078.         end;
  1079.  
  1080.         procedure ReadCouple (C: TCouple);
  1081.             var
  1082.                 N: longint;
  1083.                 T: str255;
  1084.         begin
  1085.             ReadNewLine;
  1086.             T := NextField;    {Skip record number}
  1087.             StringToNum(NextField, N);
  1088.             C.fDate := N;
  1089.             StringToNum(NextField, N);
  1090.             C.husband := TPerson(fMen.At(N));
  1091.             StringToNum(NextField, N);
  1092.             C.wife := TPerson(fWomen.At(N));
  1093. {$IFC qDebug}
  1094.             WRITELN(T, ' ', C.husband.fFirst, '-', C.wife.fFirst);
  1095. {$ENDC}
  1096.             C.husband.AddSpouse(C);
  1097.         end;
  1098.  
  1099.     begin
  1100.         new(F);
  1101.         FailNil(F);
  1102.         F.ITextFile(aRefNum, kTempMem);
  1103.  
  1104.         InitLists;
  1105. {$IFC qDebug}
  1106.         WRITELN(fMen.fSize, fWomen.fSize, fCouples.fSize);
  1107. {$ENDC}
  1108.         fMen.Each(ReadPerson);
  1109.         fWomen.Each(ReadPerson);
  1110.         fCouples.Each(ReadCouple);
  1111.  
  1112.         fMen.Sort;
  1113.         fWomen.Sort;
  1114.         F.Free;
  1115.     end;
  1116.  
  1117.     procedure TFamilyDoc.DoWrite (aRefNum: INTEGER; makingCopy: BOOLEAN);
  1118.         OVERRIDE;
  1119.         var
  1120.             F: TTextFile;
  1121.             k: integer;
  1122.             S: str255;
  1123.  
  1124.         procedure ConcatLongint (N: longint);
  1125.             var
  1126.                 T: str255;
  1127.         begin
  1128.             NumToString(N, T);
  1129.             S := concat(S, chTAB, T);
  1130.         end;
  1131.  
  1132.         procedure ConcatObjectID (P: TObject; L: TList);
  1133.         begin
  1134.             if (P = nil) | (L = nil) | (L.fSize = 0) then
  1135.                 ConcatLongint(0)
  1136.             else
  1137.                 ConcatLongint(L.GetSameItemNo(P));
  1138.         end;
  1139.  
  1140.         procedure WritePerson (P: TPerson);
  1141.         begin
  1142.             k := k + 1;
  1143.             NumToString(k, S);
  1144.             S := concat(S, chTAB, P.fFirst, chTAB, P.fLast, chTAB, P.fPlace);
  1145.             ConcatLongint(P.fBirth);
  1146.             ConcatLongint(P.fDeath);
  1147.             ConcatObjectID(P.parents, fCouples);
  1148.             F.WriteLine(S);
  1149.         end;
  1150.  
  1151.         procedure WriteCouple (C: TCouple);
  1152.         begin
  1153.             k := k + 1;
  1154.             NumToString(k, S);
  1155.             ConcatLongint(C.fDate);
  1156.             ConcatObjectID(C.husband, fMen);
  1157.             ConcatObjectID(C.wife, fWomen);
  1158.             F.WriteLine(S);
  1159.         end;
  1160.  
  1161.     begin
  1162.         new(F);
  1163.         FailNil(F);
  1164.         F.ITextFile(aRefNum, kDisk);
  1165.  
  1166.         NumToString(fMen.fSize, S);
  1167.         ConcatLongint(fWomen.fSize);
  1168.         ConcatLongint(fCouples.fSize);
  1169.         F.WriteLine(S);
  1170.  
  1171.         k := 0;
  1172.         fMen.Each(WritePerson);
  1173.         k := 0;
  1174.         fWomen.Each(WritePerson);
  1175.         k := 0;
  1176.         fCouples.Each(WriteCouple);
  1177.  
  1178.         F.Free;
  1179.     end;
  1180.  
  1181.     procedure TFamilyDoc.DoNeedDiskSpace (var dataForkBytes, rsrcForkBytes: LONGINT);
  1182.         OVERRIDE;
  1183.     begin
  1184.         dataForkBytes := dataForkBytes + 50 * (fMen.fSize + fWomen.fSize + fCouples.fSize);
  1185.     end;
  1186.  
  1187. {==========================================================================}
  1188. {        TPersonCluster                                            }
  1189. {==========================================================================}
  1190.     procedure TPersonCluster.Init;
  1191.     begin
  1192.         iMale := TCheckBox(FindSubView('male'));
  1193.         FailNIL(iMale);
  1194.         iFrst := TEditText(FindSubView('frst'));
  1195.         FailNIL(iFrst);
  1196.         iLast := TEditText(FindSubView('last'));
  1197.         FailNIL(iLast);
  1198.         iPlac := TEditText(FindSubView('plac'));
  1199.         FailNIL(iPlac);
  1200.         iBirt := TNumberText(FindSubView('birt'));
  1201.         FailNIL(iBirt);
  1202.         iDeat := TNumberText(FindSubView('deat'));
  1203.         FailNIL(iDeat);
  1204.         iNote := TEditText(FindSubView('note'));
  1205.         FailNIL(iNote);
  1206.     end;
  1207.  
  1208.     procedure TPersonCluster.GetDataFrom (P: TPerson);
  1209.     begin
  1210.         iMale.SetState(P.fMale, not kRedraw);
  1211.         iFrst.SetText(P.fFirst, false);
  1212.         iLast.SetText(P.fLast, false);
  1213.         iPlac.SetText(P.fPlace, false);
  1214.         iBirt.SetValue(P.fBirth, false);
  1215.         iDeat.SetValue(P.fDeath, false);
  1216.         if (P.fLast = '') & (P.Father <> nil) then
  1217.             iLast.SetText(P.Father.fLast, false);
  1218.     end;
  1219.  
  1220.     procedure TPersonCluster.PutDataInto (P: TPerson);
  1221.         var
  1222.             S: str255;
  1223.     begin
  1224.         P.fMale := iMale.isOn;
  1225.         iFrst.GetText(S);
  1226.         P.fFirst := S;
  1227.         iLast.GetText(S);
  1228.         P.fLast := S;
  1229.         iPlac.GetText(S);
  1230.         P.fPlace := S;
  1231.         P.fBirth := iBirt.GetValue;
  1232.         P.fDeath := iDeat.GetValue;
  1233.     end;
  1234.  
  1235. {==========================================================================}
  1236. {        TFamilyView                                            }
  1237. {==========================================================================}
  1238.     procedure TFamilyView.GetItemText (anItem: INTEGER; var aString: Str255);
  1239.         OVERRIDE;
  1240.         var
  1241.             D: TFamilyDoc;
  1242.             P: TPerson;
  1243.     begin
  1244.         if anItem = fNumOfRows then
  1245.             aString := kDontExist
  1246.         else
  1247.             begin
  1248.                 D := TFamilyDoc(fdocument);
  1249.                 P := TPerson(D.fFamily.At(anItem));
  1250.                 if (anItem in fSpouses) then
  1251.                     aString := concat(P.fFirst, ' ', P.fLast)
  1252. {     else if P.fBirth = 0 then }
  1253. {      aString := P.fFirst }
  1254.                 else
  1255.                     aString := concat(P.fFirst, '  ', P.FullBirth);
  1256.             end;
  1257.     end;
  1258.  
  1259. {$IFC undefined THINK_Pascal}
  1260. function ModifierKeyIsDown: Boolean;
  1261. const
  1262.     kOptionKey = 58;
  1263.     kShiftKey = 56;
  1264. var theKeys: KeyMap;
  1265. begin
  1266.     GetKeys(theKeys);
  1267.     ModifierKeyIsDown := theKeys[kOptionKey] | theKeys[kShiftKey];
  1268. end;
  1269. {$ENDC}
  1270.  
  1271.     procedure TFamilyView.SelectItem (anItem: INTEGER; extendSelection, highlight, select: BOOLEAN);
  1272.         OVERRIDE;
  1273.         var
  1274.             D: TFamilyDoc;
  1275.             P: TPerson;
  1276.             C: TCouple;
  1277.     begin
  1278.         inherited SelectItem(anItem, extendSelection, highlight, select);
  1279.  
  1280.         if anItem = 0 then
  1281.             Exit(SelectItem);
  1282.  
  1283.         D := TFamilyDoc(fdocument);
  1284.         if anItem < fNumOfRows then
  1285.             begin        { click on a person P }
  1286.                 P := TPerson(D.fFamily.At(anItem));
  1287.                 if not (anItem in fSpouses) & ModifierKeyIsDown then
  1288.                     begin
  1289.                         C := P.parents;
  1290.                         if D.EditCouple(C, 'Husband', 'Wife') then
  1291.                             ;
  1292.                         P := D.fCurrent;
  1293.                     end;
  1294.             end
  1295.         else if (anItem = 1) | ModifierKeyIsDown then
  1296.             begin        { click on ** -- empty list or option key }
  1297.                 P := D.fCurrent;
  1298.                 D.AddSpouse;
  1299.             end
  1300.         else
  1301.             begin        { plain click on ** -- non-empty list }
  1302.                 P := D.fCurrent;
  1303.                 D.AddChild;
  1304.             end;
  1305. {$IFC false}
  1306.         WRITELN('Select item  ', anItem : 1, '  ', P.fFirst);
  1307. {$ENDC}
  1308.         if P <> nil then
  1309.             D.SetPerson(P);
  1310.     end;
  1311.  
  1312.     procedure TFamilyView.SetNumberOfItems (aNumber: INTEGER);
  1313.     begin
  1314.         ForceRedraw;
  1315.  
  1316.         if fNumOfRows > aNumber then
  1317.             DelItemFirst(fNumOfRows - aNumber)
  1318.         else if fNumOfRows < aNumber then
  1319.             InsItemFirst(aNumber - fNumOfRows);
  1320.     end;
  1321.  
  1322.     function TFamilyView.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
  1323.         OVERRIDE;
  1324.         var
  1325.             h: CursHandle;
  1326.             R: Rect;
  1327.     begin
  1328.         h := GetCursor(kHandCursor);
  1329.         if h <> nil then
  1330.             SetCursor(h^^);
  1331.         GetQDExtent(R);
  1332.         RectRgn(cursorRgn, R);
  1333.         DoSetCursor := TRUE;
  1334.     end;
  1335.  
  1336.     procedure TFamilyView.DrawCell (aCell: GridCell; aQDRect: Rect);
  1337.         OVERRIDE;
  1338.         var
  1339.             k: integer;
  1340.             S: Str255;
  1341.             D: TFamilyDoc;
  1342.     begin
  1343.         GetText(aCell, S);
  1344.  
  1345.         k := aCell.v;
  1346.         if (k in fSpouses) then
  1347.             TextFace([bold])
  1348.         else
  1349.             TextFace([]);
  1350.  
  1351.         D := TFamilyDoc(fdocument);
  1352.         if k = fNumOfRows then
  1353.             SetIfColor(gRGBBlack)
  1354.         else if TPerson(D.fFamily.At(k)).fMale then
  1355.             SetIfColor(gBlue)
  1356.         else
  1357.             SetIfColor(gRed);
  1358.  
  1359.         if (GetColWidth(aCell.h) > 0) then
  1360.             MADrawString(@S, aQDRect, teJustCenter);
  1361.     end;
  1362.  
  1363. {==========================================================================}
  1364. {        TActiveText                                            }
  1365. {==========================================================================}
  1366.     function TActiveText.DoSetCursor (localPoint: Point; cursorRgn: RgnHandle): BOOLEAN;
  1367.         OVERRIDE;
  1368.         var
  1369.             h: CursHandle;
  1370.             R: Rect;
  1371.     begin
  1372.         h := GetCursor(kHandCursor);
  1373.         if h <> nil then
  1374.             SetCursor(h^^);
  1375.         GetQDExtent(R);
  1376.         RectRgn(cursorRgn, R);
  1377.         DoSetCursor := TRUE;
  1378.     end;
  1379.  
  1380.     procedure TActiveText.DoChoice (origView: TView; itsChoice: INTEGER);
  1381.         OVERRIDE;
  1382.         var
  1383.             D: TFamilyDoc;
  1384.             P: TPerson;
  1385.             C: TCouple;
  1386.     begin
  1387.         D := TFamilyDoc(fdocument);
  1388.         if fPerson = nil then
  1389.             begin
  1390.                 P := D.fCurrent;
  1391.                 D.AddParents;
  1392.             end
  1393.         else if ModifierKeyIsDown then
  1394.             begin
  1395.                 P := D.fCurrent;
  1396.                 C := D.fCurrent.parents;
  1397.                 if D.EditCouple(C, 'Father', 'Mother') then
  1398.                     ;
  1399.             end
  1400.         else
  1401.             P := fPerson;
  1402. {$IFC false}
  1403.         WRITELN('DoChoice  ', fIdentifier);
  1404. {$ENDC}
  1405.         if P <> nil then
  1406.             D.SetPerson(P);
  1407.     end;
  1408.  
  1409.     procedure TActiveText.SetPerson (P: TPerson);
  1410.     begin
  1411.         fPerson := P;
  1412.         if P = nil then
  1413.             SetText(kDontExist, kRedraw)
  1414.         else
  1415.             SetText(P.fFirst, kRedraw);
  1416.     end;
  1417.  
  1418.  
  1419. {==========================================================================}
  1420. {        Fields                                                }
  1421. {==========================================================================}
  1422.     procedure TPerson.GetInspectorName (var inspectorName: Str255);
  1423.         OVERRIDE;
  1424.     begin
  1425.         inspectorName := fFirst;
  1426.     end;
  1427.  
  1428.     procedure TPerson.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  1429.         OVERRIDE;
  1430.     begin
  1431.     end;
  1432.  
  1433.     procedure TPerson.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  1434.         OVERRIDE;
  1435.         var
  1436.             k: integer;
  1437.             S: str255;
  1438.             X: TObject;
  1439.     begin
  1440.         if fMale then
  1441.             DoToField('TPerson (male)', nil, bClass)
  1442.         else
  1443.             DoToField('TPerson (female)', nil, bClass);
  1444.         DoToField('first', @fFirst, bString);
  1445.         DoToField('last', @fLast, bString);
  1446.         DoToField('birth', @fBirth, bLongint);
  1447.         DoToField('death', @fDeath, bLongint);
  1448.         DoToField('place', @fPlace, bString);
  1449.         DoToField('parents', @parents, bObject);
  1450.         if parents <> nil then
  1451.             begin
  1452.                 DoToField('  father', @parents.husband, bObject);
  1453.                 DoToField('  mother', @parents.wife, bObject);
  1454.             end;
  1455.         if fSize > 0 then
  1456.             DoToField('spouses', nil, bTitle);
  1457.         for k := 1 to fSize do
  1458.             begin
  1459.                 X := At(k);
  1460.                 NumToString(k, S);
  1461.                 DoToField(S, @X, bObject);
  1462.             end;
  1463.  
  1464.         inherited Fields(DoToField);
  1465.     end;
  1466.  
  1467.     procedure TCouple.GetInspectorName (var inspectorName: Str255);
  1468.         OVERRIDE;
  1469.     begin
  1470.         inspectorName := concat(husband.fFirst, '-', wife.fFirst);
  1471.     end;
  1472.  
  1473.     procedure TCouple.DynamicFields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  1474.         OVERRIDE;
  1475.     begin
  1476.     end;
  1477.  
  1478.     procedure TCouple.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  1479.         OVERRIDE;
  1480.         var
  1481.             k: ArrayIndex;
  1482.             S: Str255;
  1483.             X: TObject;
  1484.     begin
  1485.         DoToField('TCouple', nil, bClass);
  1486.         DoToField('husband', @husband, bObject);
  1487.         DoToField('wife', @wife, bObject);
  1488.         DoToField('date', @fDate, bLongint);
  1489.         DoToField('children', nil, bTitle);
  1490.         for k := 1 to fSize do
  1491.             begin
  1492.                 X := At(k);
  1493.                 NumToString(k, S);
  1494.                 DoToField(S, @X, bObject);
  1495.             end;
  1496.  
  1497.         inherited Fields(DoToField);
  1498.     end;
  1499.  
  1500.     procedure TFamilyDoc.Fields (procedure DoToField (fieldName: Str255; fieldAddr: Ptr; fieldType: integer));
  1501.         OVERRIDE;
  1502.     begin
  1503.         DoToField('TFamilyDoc', nil, bClass);
  1504.         DoToField('fMen', @fMen, bObject);
  1505.         DoToField('fWomen', @fWomen, bObject);
  1506.         DoToField('fCouples', @fCouples, bObject);
  1507.         DoToField('fCurrent', @fCurrent, bObject);
  1508.         DoToField('fFamily', @fFamily, bObject);
  1509.         DoToField('fSpouses', @iFamily.fSpouses, bLongint);
  1510.  
  1511.         inherited Fields(DoToField);
  1512.     end;
  1513.  
  1514. end.